home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / s_to_z / statone / dynary.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  7KB  |  280 lines
  1. unit dynary;
  2.  
  3. interface
  4.  
  5. uses
  6.       SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.       Forms, Dialogs;
  8.  
  9. const
  10.     MAX_SIZE = 8000;
  11.     VERSION = 'Ver 0.3';
  12.  
  13. type
  14.     CompFunc = Function(V1,V2:Pointer):Boolean;
  15.     TElement = Double;
  16.   TIndex = WORD;
  17.     PElement = ^TElement;
  18.   TTheArray = Array[1..MAX_SIZE] of TElement;
  19.   PArray = ^TTheArray;
  20.  
  21.   TDoubleArray     = class(TComponent)
  22.  
  23.   private
  24.     { Private declarations }
  25.     FAbout: string;
  26.         FSize: TIndex;
  27.     FArray: TTheArray;
  28.     FArrayPtr: PArray;
  29.     FArrayAssigned: Boolean;
  30.     PROCEDURE SetArrayValue(idx: TIndex; CONST NewElement: TElement);
  31.     FUNCTION GetArrayValue(idx: TIndex): TElement;
  32.     PROCEDURE CreateArray(CONST Size: TIndex);
  33.     PROCEDURE DestroyArray;
  34.     PROCEDURE InitializeArrayElements(CONST LoInit, HiInit:TIndex);
  35.     procedure SetAbout(value: string);
  36.  
  37.   protected
  38.  
  39.   public
  40.     property Value[idx: TIndex]: TElement read GetArrayValue write SetArrayValue; default;
  41.     procedure Sort;
  42.     {property AddrOfElement[idx: TIndex]: PElement read GetElementAddress;}
  43.  
  44.   published
  45.     property Size: TIndex read  FSize write FSize;
  46.     FUNCTION CheckRange(CONST N: TIndex):BOOLEAN;
  47.     FUNCTION SetSize(Size: TIndex): BOOLEAN;
  48.     constructor Create(AOwner: TComponent); override;
  49.     destructor Destroy; override;
  50.     property About: string read FAbout write SetAbout;
  51. end;
  52.  
  53. Procedure SortProcedure(Var     Struct;                    { array of any Type }
  54.                                         Num,            { Number of elements }
  55.                                         ElementSize:Integer;   { Size of each element ( byte ) }
  56.                                         Comp:CompFunc); { Type of compare function to use}
  57.  
  58. Function IntComp(I1,I2:Pointer):Boolean;   far;
  59. Function SingleComp(r1,r2:Pointer):Boolean;  far;
  60. Function RealComp(r1,r2:Pointer):Boolean;  far;
  61. Function DoubleComp(r1,r2:Pointer):Boolean;  far;
  62. Function ByteComp(b1,b2:Pointer):Boolean;  far;
  63. Function CharComp(c1,c2:Pointer):Boolean;  far;
  64. Function StringComp(s1,s2:Pointer):Boolean;far;
  65.  
  66. procedure register;
  67.  
  68. {===========================================}
  69. implementation
  70. CONSTRUCTOR TDoubleArray.Create(AOwner: TComponent);
  71. BEGIN
  72.   inherited Create(AOwner);
  73.   FAbout := VERSION;
  74.   IF FSize > 0 THEN
  75.     CreateArray(Size)
  76.   ELSE
  77.     FArrayAssigned := FALSE;
  78.     FSize := 0;
  79. END;
  80.  
  81. DESTRUCTOR TDoubleArray.Destroy;
  82. BEGIN
  83.   DestroyArray;
  84.   inherited Destroy;
  85. END;
  86.  
  87. PROCEDURE TDoubleArray.InitializeArrayElements (CONST LoInit, HiInit: TIndex);
  88. VAR
  89.     idx: TIndex;
  90. BEGIN
  91.   FOR idx := LoInit TO HiInit DO
  92.     FArrayPtr^[idx] := 0.0;
  93. END;
  94.  
  95. PROCEDURE TDoubleArray.CreateArray(CONST Size: TIndex);
  96. BEGIN
  97.   GetMem(FArrayPtr, Size * SizeOf(TElement));
  98.   FSize := Size;
  99.   InitializeArrayElements(1, FSize);
  100.   FArrayAssigned := TRUE
  101. END;
  102.  
  103. PROCEDURE TDoubleArray.DestroyArray;
  104. BEGIN
  105.   FreeMem(FArrayPtr, FSize * SizeOf(TElement));
  106.   FArrayAssigned := FALSE;
  107. END;
  108.  
  109. FUNCTION TDoubleArray.CheckRange(CONST N: TIndex): BOOLEAN;
  110. BEGIN
  111.   IF (N > FSize) OR (N < 1) THEN
  112.     Result := FALSE
  113.   ELSE
  114.     Result := TRUE;
  115. END;
  116.  
  117. PROCEDURE TDoubleArray.SetArrayValue(idx: TIndex; CONST NewElement: TElement);
  118. BEGIN
  119.   FArray[idx] := NewElement;
  120. END;
  121.  
  122. FUNCTION TDoubleArray.GetArrayValue(idx: TIndex): TElement;
  123. BEGIN
  124.   Result := FArray[idx];
  125. END;
  126.  
  127. FUNCTION TDoubleArray.SetSize(Size: TIndex): BOOLEAN;
  128. BEGIN
  129.     {CHECK THE RANGE}
  130.     IF (Size > MAX_SIZE) OR (Size < 1) THEN
  131.   BEGIN
  132.       Result := FALSE;
  133.     Exit;
  134.   END;
  135.  
  136.   {SET THE SIZE}
  137.   IF FArrayAssigned = FALSE THEN
  138.       CreateArray(Size)
  139.   ELSE
  140.   begin
  141.       {REALLOCATE ARRAY ROUTINE HERE}
  142.     FreeMem(FArrayPtr, FSize * SizeOf(TElement));
  143.       FArrayAssigned := FALSE;
  144.       CreateArray(Size)
  145.   end;
  146. END;
  147.  
  148. procedure TDoubleArray.Sort;
  149. begin
  150.     if FSize > 1 then
  151.     SortProcedure(FArray, FSize, 8, DoubleComp);
  152. end;
  153.  
  154.  
  155. Procedure SortProcedure{...};
  156.  
  157.   var
  158.     Temp:Pointer;
  159.     StructBase:Array[0..0] of Byte Absolute Struct;
  160.  
  161.   Function VLoc(n:integer):Pointer;
  162.     { Note that no range check is performed! }
  163.     Begin
  164.       {$R-}
  165.       VLoc:=Addr(structBase[n*ElementSize]);
  166.       {$R+}
  167.     End;
  168.  
  169.   Procedure Swap(n1,n2:Integer);
  170.     { swap two elements }
  171.     Begin
  172.       Move(VLoc(n1)^,Temp^,ElementSize);
  173.       Move(VLoc(n2)^,VLoc(n1)^,ElementSize);
  174.       Move(Temp^,VLoc(n2)^,ElementSize);
  175.     End;
  176.  
  177.   { Quick sort routine }
  178.   Procedure Qsort(l,r:Integer);
  179.     Var
  180.       i,j:Integer;
  181.       Pivot:Pointer;
  182.     Begin
  183.       i:=l;
  184.       j:=r;
  185.       GetMem(Pivot,ElementSize);  { Hopefully, the midpoint}
  186.       Move(Vloc((L+r) div 2)^,Pivot^,ElementSize);
  187.       Repeat
  188.         while Comp(Pivot,Vloc(i)) do inc(i);
  189.         while Comp(Vloc(J),pivot) do Dec(j);
  190.         if i<=j then
  191.           Begin
  192.             Swap(i,j);
  193.             Inc(i);
  194.             Dec(j);
  195.           End;
  196.       until i>j;
  197.       if j>l then Qsort(l,j); { recoursive call }
  198.       if i<r then Qsort(i,r);
  199.       FreeMem(Pivot,ElementSize);
  200.     End;
  201.   begin
  202.       GetMem(Temp,ElementSize);   { Temp is used for swap }
  203.     if num>1 then
  204.       Qsort(0,Num-1);
  205.     FreeMem(Temp,ElementSize);
  206.   end;
  207.  
  208. Function IntComp(I1,I2:Pointer):Boolean;
  209.   Type
  210.     IntPtr=^Integer;
  211.   Var
  212.     v1:IntPtr absolute I1;
  213.     v2:IntPtr absolute I2;
  214.   Begin
  215.     IntComp:=V1^>V2^;
  216.   End;
  217. Function SingleComp(r1,r2:Pointer):Boolean;
  218.   Type
  219.     SinglePtr=^Single;
  220.   Var
  221.     v1:SinglePtr absolute r1;
  222.     v2:SinglePtr absolute r2;
  223.   Begin
  224.     SingleComp:=V1^>V2^;
  225.   End;
  226. Function RealComp(r1,r2:Pointer):Boolean;
  227.   Type
  228.     RealPtr=^Real;
  229.   Var
  230.     v1:RealPtr absolute r1;
  231.     v2:RealPtr absolute r2;
  232.   Begin
  233.     RealComp:=V1^>V2^;
  234.   End;
  235. Function DoubleComp(r1,r2:Pointer):Boolean;
  236.   Type
  237.     DoublePtr=^Double;
  238.   Var
  239.     v1:DoublePtr absolute r1;
  240.     v2:DoublePtr absolute r2;
  241.   Begin
  242.     DoubleComp:=V1^>V2^;
  243.   End;
  244. Function ByteComp(b1,b2:Pointer):Boolean;
  245.   Type
  246.     BytePtr=^Byte;
  247.   Var
  248.     v1:BytePtr absolute b1;
  249.     v2:BytePtr absolute b2;
  250.   Begin
  251.     ByteComp:=V1^>V2^;
  252.   End;
  253. Function CharComp(c1,c2:Pointer):Boolean;
  254.   Begin
  255.     CharComp:=ByteComp(c1,c2); { Byte and char are the same! }
  256.   End;
  257. Function StringComp(s1,s2:Pointer):Boolean;
  258.   Type
  259.     StringPtr=^String;
  260.   Var
  261.     v1:StringPtr absolute s1;
  262.     v2:StringPtr absolute s2;
  263.   Begin
  264.     StringComp:=V1^>V2^;
  265.   End;
  266.  
  267. procedure TDoubleArray.SetAbout(value: string);
  268. begin
  269.     FAbout := VERSION;
  270. end;
  271.  
  272. PROCEDURE Register;
  273. BEGIN
  274.     RegisterComponents('Ted', [TDoubleArray]);
  275. END;
  276.  
  277. end.
  278.  
  279.  
  280.